#!/usr/bin/Rscript
##########################################################################################
# Issue Ownership and Agenda Setting in the 2019 Swiss National Elections
##########################################################################################
# Description:
# VAR Analysis
##########################################################################################
# Content
##########################################################################################
# 1) Dependencies
# 2) Load Data
# 3) Data Wrangling
# 4) Model Maker
# 5) CALCULATING ONE-TIME and PERMANENT 10-POINT EFFECTS
# 6)  MAIN
##########################################################################################
# 1) Dependencies
##########################################################################################
library(tidyr)
library(dplyr)
library(vars)
library(boot)
library(rio)
library(ggplot2)
library(forecast)
library(urca)
##########################################################################################
# 2) Load Data
##########################################################################################
rm(list=ls())
# - set dir
args = commandArgs()

scriptName = args[substr(args,1,7) == '--file=']

if (length(scriptName) == 0) {
  scriptName <- rstudioapi::getSourceEditorContext()$path
} else {
  scriptName <- substr(scriptName, 8, nchar(scriptName))
}

pathName = substr(
  scriptName, 
  1, 
  nchar(scriptName) - nchar(strsplit(scriptName, '.*[/|\\]')[[1]][2])
)

setwd(pathName)
parent_path <- getwd()


db <- readRDS("../data/main_data_for_paper_all_topics_sep_party_19jan_appendix.RDS")

# Effect Measurement after how many weeks: 1
week_set <- seq(1,2, by = 1)
##########################################################################################
# 3) Data Wrangling
##########################################################################################
# - creating a list with the variables of interest. For the new iteration
variables <- c("Media_SMD", #"Media_TW", "Org_TW", "Org_PR", "Gov_TW",
              "Party_FDP_TW", "Party_GLP_TW", "Party_Grüne_TW","Party_SP_TW", "Party_SVP_TW", "Party_CVP_TW")

# - creating list of interesting topics for model configuration
mod_conf <- list(c("Environment_Energy"), 
                 c("GenderIssues_Discrimination"),
                 c("Immigration_Asylum"),
                 c("EU_Europa"),
                 c("Environment_Energy", "GenderIssues_Discrimination", "Immigration_Asylum", "EU_Europa"))

mod_name <- c("Environment_Energy", "Gender_Issues", "Immigration_Asylum", "EU_Europa", "All_Four")

# - selecting only the variables of interest
db <- db[, c("pubDateTime", "selectsclass", variables)]
db_spar <- db[, c(variables)]

# - logit transform all series
for (v in variables) {
  # - pulling the series-agenda for that group
  x <- db[,v]
  # - for some groups the last couple observations for each issues are NA,
  #     making these a 0 
  x[which(is.na(x)),] <- 0.01
  # - adding 1 percentage point to avoid 0s before the logit transformation
  #x <- x + 0.01
  # - applying the non-linear transformation
  logit_x <- log(x / (1-x))
  # If a topic makes up 100 % on a week transform the inf value to 11.51292 which equals 99 %
  logit_x[mapply(is.infinite, logit_x)] <- 4.59512
  db[,v] <- logit_x
}


# calculate sparsity:
for (v in variables) {
  # - pulling the series-agenda for that group
  x <- db_spar[,v]
  # - for some groups the last couple observations for each issues are NA,
  #     making these a 0 
  x[which(is.na(x)),] <- 0.00
  db_spar[,v] <- x
}

sum(db_spar == 0)/(dim(db_spar)[1]*dim(db_spar)[2])

# - creating a list with the variables of interest
variables <- c("Media_SMD", #"Media_TW", "Org_TW", "Org_PR",  "Gov_TW",
               "Party_FDP_TW", "Party_GLP_TW", "Party_Grüne_TW","Party_SP_TW", "Party_SVP_TW", "Party_CVP_TW")
##########################################################################################
# 4) Model Maker
##########################################################################################
##########################################################################################
# 4.1) Find best model for all Topics:
##########################################################################################
p_for_each_topic <- data.frame(mod_name,c(1,2,3,4,5),c(1,2,3,4,5),c(1,2,3,4,5),c(1,2,3,4,5))
colnames(p_for_each_topic) <- c("Topics", "Best P AIC", "Best P HQ", "Best P SC", "Best P FPE")
for(f in 1:length(mod_conf)){
  top_mod <- unlist(mod_conf[f])
  finddb <- db %>% filter(selectsclass %in% top_mod)
  finddb$pubDateTime <- as.numeric(finddb$pubDateTime)
  
  finddb$selectsclass <- as.factor(finddb$selectsclass)
  topic_levels <- levels(finddb$selectsclass)
  
  finddb$selectsclass <- as.numeric(finddb$selectsclass)
  mformula_f <- formula(paste0("~", 
                               paste0(variables, collapse = " + ")))
  model_data_f <- model.matrix(mformula_f, finddb[, variables])
  model_data_f <- model_data_f[, 2:ncol(model_data_f)] # removing intercept
  
  #Dickey-Fuller Test to determine Stationary differences to achieve stationarity.
  stationarity <- ndiffs(model_data_f, alpha = 0.01, test = c("adf"))
  
  if(stationarity == 0){
    # - splitting the covariates of interest from the issue dummy variables
    X_endogenous_f <- model_data_f[, which(!grepl("selectsclass", colnames(model_data_f)))]
    X_exogenous_f <- model_data_f[, which(grepl("selectsclass", colnames(model_data_f)))]
    
    if(ncol(X_exogenous_f) == 0){
      var_model_find_lag <- VARselect(y = X_endogenous_f, lag.max = 18)
    } else {
      var_model_find_lag <- VARselect(y = X_endogenous_f, exogen = X_exogenous_f, lag.max = 18)
    }
    p_for_each_topic[f,2:5] <- var_model_find_lag$selection
  } else {
    cat("The Topic ", mod_conf[f], " is not stationary at the moment!\n")
    # Since this never triggers we do not need to transform the data!
  }
  
}

p_for_each_topic

# Lagorder is one here since we use only one week before to estimate the week after which is equal to the lgorder of 7 we use in the daily var wher we look at the effects of seven days
p_for_topics <- c(1,1,1,1,1)
##########################################################################################
# 4.2) Calculate Models with best lag:
##########################################################################################
var_model_merged <- list()
var_irfs_cum_merged <- list()

for(j in 1:length(mod_conf)){
  
  p_best <- p_for_topics[j]
  
  configuration_j <- mod_conf[[j]]
  
  maindb <- db %>% filter(selectsclass %in% configuration_j)
  maindb$pubDateTime <- as.numeric(maindb$pubDateTime)
  
  # - a formula object that will facilitate transforming the topic variable from
  #     factor to dummies
  maindb$selectsclass <- as.factor(maindb$selectsclass)
  topic_levels <- levels(maindb$selectsclass)
  
  maindb$selectsclass <- as.numeric(maindb$selectsclass)
  mformula <- formula(paste0("~ ", 
                             paste0(c(variables), collapse = " + ")))
  model_data <- model.matrix(mformula, maindb[, variables])
  model_data <- model_data[, 2:ncol(model_data)] # removing intercept
  
  # - splitting the covariates of interest from the issue dummy variables
  X_endogenous <- model_data[, which(!grepl("selectsclass", colnames(model_data)))]
  X_exogenous <- model_data[, which(grepl("selectsclass", colnames(model_data)))]
  
  if(length(X_exogenous) == 0){
    # - estimating the model: 1 lag since this is only logical while looking at all test criterias
    var_model_merged_tmp <- VAR(y = X_endogenous, p = p_best)
    
    var_irfs_cum_merged_tmp <- irf(var_model_merged_tmp, n.ahead = 9, cumulative = TRUE)
  } else {
    # - estimating the model: 1 lag since this is only logical while looking at all test criterias
    var_model_merged_tmp <- VAR(y = X_endogenous, p = p_best, exogen = X_exogenous)
    
    var_irfs_cum_merged_tmp <- irf(var_model_merged_tmp, n.ahead = 9, cumulative = TRUE)
  }
  #Save different Models in List of Lists
  if(j == 1){
    var_model_merged <- list(var_model_merged_tmp)
    var_irfs_cum_merged <- list(var_irfs_cum_merged_tmp)
  } else {
    var_model_merged[[j]] <- var_model_merged_tmp
    var_irfs_cum_merged[[j]] <- var_irfs_cum_merged_tmp
  }
}

# Lets consider the presence of heteroscedasticity. 
# In time series, there is what we call ARCH effects which are essentially clustered volatility areas in a time series.
for(a in 1:length(var_model_merged)){
  sertest <- arch.test(var_model_merged[[a]], lags.multi = 12, multivariate.only = TRUE)
  # If p >= 0.05: The null hypothesis of no heteroscedasticity is rejected since the p-value 
  # of X is lower than the significance level alpha of 0.05. 
  cat(paste0("p-value: ", sertest[["arch.mul"]][["p.value"]], "\n"))
}
# Criteria is met!

# PART-4 OUTPUT
saveRDS(var_model_merged, "../var/var_model_all_big_jan_appendix.RDS")
saveRDS(var_irfs_cum_merged, "../var/var_irfs_main_all_big_jan_appendix.RDS")
##########################################################################################
# 5) CALCULATING ONE-TIME and PERMANENT 10-POINT EFFECTS
##########################################################################################
var_irfs <- var_irfs_cum_merged
irf_data <- list()

# Loop through all configurations
for(k in 1:length(var_irfs)){
  # Get Model K:
  var_irfs_k <- var_irfs[[k]]
  
  variables <- names(var_irfs_k$irf)
  
  # - a list with the elements of interest from the IRF object
  elements_to_pull <- c("irf", "Upper", "Lower")
  
  # - initializing and filling a dataset with the IRF info
  irf_data_tmp <- NULL
  for (el in elements_to_pull) {
    new_irf_info <- var_irfs_k[el][[1]]
    for (out in variables) {
      new_irf_var_data <- as.data.frame(new_irf_info[out][[1]])
      # - take inverse logit to transform the effects to percentage point changes
      new_irf_var_data_transf <- as.data.frame(
        sapply(1:ncol(new_irf_var_data), function(j)
          inv.logit(new_irf_var_data[,j]) - 0.5))
      colnames(new_irf_var_data_transf) <- colnames(new_irf_var_data)
      new_irf_var_data_long <- new_irf_var_data_transf %>%
        tidyr::gather(cov, value)
      new_irf_var_data_long$out <- out
      new_irf_var_data_long$week <- rep(1:nrow(new_irf_var_data), 
                                       length(unique(new_irf_var_data_long$cov)))
      new_irf_var_data_long$e_type <- el
      irf_data_tmp <- rbind(irf_data_tmp, new_irf_var_data_long)
    }
  }
  
  # - give easier labels to the estimate types (e.g. Lower --> lwr)
  irf_data_tmp$e_type <- recode(irf_data_tmp$e_type,
                                `irf` = "pe",
                                `Lower` = "lwr", 
                                `Upper` = "upr")
  if(k == 1){
    irf_data <- list(irf_data_tmp)
  } else {
    irf_data[[k]] <- irf_data_tmp
  }
  
}
##########################################################################################
# 6)  MAIN
##########################################################################################
for(l in 1:length(irf_data)){
  new_irf_data <- NULL
  # - a vector with the name of the variables
  variables <- unique(irf_data[[l]]$cov)
  
  # - deciding the number of weeks to simulate
  WEKKS <- 9
  
  tmpirf <- irf_data[[l]]
  
  irf_data_tmp <- tmpirf %>%
    filter(week <= (WEKKS + 1))
  
  # - iterating through covariates
  for (covariate in variables) {
    # -iterating through outcomes
    for (outcome in variables) {
      # - skipping when covariate and response are the same
      if (covariate != outcome) {
        # - initializing a cummulative-shocks matrix for this scenario: two 3-dim 
        #     matrix, one matrix for the covariate and one matrix for the response,
        #     and one dimension for the point estimate and the two other dimensions
        #     for the lower and upper bounds of the estimate
        cov_mat <- array(0, dim = c(WEKKS, WEKKS, 3))
        out_mat <- array(0, dim = c(WEKKS, WEKKS, 3))
        
        # - pull the full 15-week IRFs for the endogenous covariate
        cov_resp <- irf_data_tmp %>%
          filter(cov == covariate, out == covariate) %>%
          # - remove 1st row: it's part of the set-up (repsonse at week 0)
          filter(week != 1) %>%
          mutate(week = week -1)
        
        # - pull the full 15-week IRFs for the particular outcome variable
        out_resp <- irf_data_tmp %>%
          filter(cov == covariate, out == outcome) %>%
          # - remove 1st row: it's part of the set-up (repsonse at week 0)
          filter(week != 1) %>%
          mutate(week = week -1)
        
        # - transforming the 15-week IRFs for the covariate and outcome to a wide
        #   3-column format (one column per estimate type: pe, lwr, upr)
        or_cov_resp <- cov_resp %>%
          dplyr::select(week, value, e_type) %>%
          tidyr::spread(e_type, value) %>%
          dplyr::select(-week)
        
        or_out_resp <- out_resp %>%
          dplyr::select(week, value, e_type) %>%
          tidyr::spread(e_type, value) %>%
          dplyr::select(-week)
        
        # - fill up the first rows of the scenario matrices with the original 
        #   1-week shock responses
        cov_mat[1,,1:3] <- or_cov_resp %>%
          as.matrix()
        out_mat[1,,1:3] <- or_out_resp %>%
          as.matrix()
        
        for (i in 2:WEKKS) {
          # - iterating through the rest of the 15 WEKKS, beyond the 1st one
          # - chekcing first how much attention the covariate group is predicted 
          #   to pay to the issue in week i-1
          cov_att_pe <- sum(cov_mat[,(i-1),2])
          
          # - calculating how big a new shock needs to be in order for the 
          #   covariate group to keep its attention to 100%
          cov_new_shock <- 1 - cov_att_pe
          
          # - re-scaling the original 100 percentage point shock to the new shock
          cov_new_resp <- or_cov_resp[1:(WEKKS-(i-1)),] * cov_new_shock
          out_new_resp <- or_out_resp[1:(WEKKS-(i-1)),] * cov_new_shock
          
          # - adding the response to this new shock to the scenario matrices
          cov_mat[i,i:WEKKS,1:3] <- cov_new_resp %>%
            as.matrix()
          out_mat[i,i:WEKKS,1:3] <- out_new_resp %>%
            as.matrix()
        }
        # - saving the output for this cov --> out 
        new_rows <- rbind(
          data.frame(
            cov = covariate,
            value = colSums(out_mat[,,1]),
            out = outcome,
            week = 1:WEKKS,
            e_type = "lwr",
            data_type = "structural"),
          data.frame(
            cov = covariate,
            value = colSums(out_mat[,,2]),
            out = outcome,
            week = 1:WEKKS,
            e_type = "pe",
            data_type = "structural"),
          data.frame(
            cov = covariate,
            value = colSums(out_mat[,,3]),
            out = outcome,
            week = 1:WEKKS,
            e_type = "upr",
            data_type = "structural")
        )
        new_irf_data <- rbind(new_irf_data, new_rows)
      }
    }
  }
  
  # - merging this new type of IRFs with the "regular" 1-time-shock IRFs
  tmpirf$data_type <- "one_time_shock"
  tmpirf <- tmpirf %>%
    # - correct the original data for the fact that week 1 is just pre-setting
    filter(week != 1) %>% 
    mutate(week = week -1)
  
  all_irf_data <- rbind(tmpirf, new_irf_data)
  
  # - removing from the dataset cases in which covariate and outcome are the same
  all_irf_data <- all_irf_data %>%
    filter(cov != out)
  
  # - a wide version of the dataset, with a separate column for each estimate type
  all_irf_data_wide <- all_irf_data %>%
    tidyr::spread(e_type, value)
  
  # - simulate one-time and structural shocks of 10 instead of 100 percentage pts.
  #   Present the results in 0-100 scale instead of 0-1
  all_irf_data_wide <- all_irf_data %>%
    mutate(value = (value / 10) * 100) %>%
    tidyr::spread(e_type, value)
  
  # - better labels for the data type
  all_irf_data_wide$data_type <- recode(
    all_irf_data_wide$data_type,
    `one_time_shock` =  "Effect of a one time 10 percentage point attention increase at week 0",
    `structural` = "Effect of a structural 10 percentage point attention increase at week 0")
  
  
  if(l == 1){
    all_irf_data_wide_all <- list(all_irf_data_wide)
  } else {
    all_irf_data_wide_all[[l]] <- all_irf_data_wide
  }
}

saveRDS(all_irf_data_wide_all,
        "../var/onetime-structural-shock-irfs-results_all_big_jan_appendix.RDS")
##########################################################################################
